home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / resource.l < prev    next >
Lisp/Scheme  |  1989-07-12  |  13KB  |  388 lines
  1. ;;; -*- Mode:Lisp; Package:CLUEI; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. (in-package 'cluei :use '(lisp xlib))
  20.  
  21. (export '(*database*
  22.        convert
  23.        define-resources
  24.        undefine-resources
  25.        ))
  26.  
  27. (export '(default-resources ;; Debug aids
  28.        class-resources
  29.        describe-resource))
  30.  
  31. (defvar *database* (make-resource-database))
  32.  
  33. (defun describe-resource (name &optional (database *database*) (max-levels 32))
  34.   "Describe the entries for NAME in DATA-BASE"
  35.   (let ((name-vector (make-array max-levels))
  36.     (tight-vector (make-array max-levels :element-type 'bit)))
  37.     (labels ((dr-internal (name database level)
  38.            (when (eq name (xlib::resource-database-name database))
  39.          (format t "~%~10s (" (xlib::resource-database-value database))
  40.          (dotimes (i level)
  41.            (when (plusp i) (princ " "))
  42.            (when (zerop (aref tight-vector i)) (princ "* "))
  43.            (princ (aref name-vector i)))
  44.          (princ ")"))
  45.            (when (xlib::resource-database-tight database)
  46.          (dolist (tight (xlib::resource-database-tight database))
  47.            (setf (aref name-vector level) (xlib::resource-database-name tight)
  48.              (aref tight-vector level) 1)
  49.            (dr-internal name tight (1+ level))))
  50.            (when (xlib::resource-database-loose database)
  51.          (dolist (loose (xlib::resource-database-loose database))
  52.            (setf (aref name-vector level) (xlib::resource-database-name loose)
  53.              (aref tight-vector level) 0)
  54.            (dr-internal name loose (1+ level))))))
  55.       (format t "~%Value      Name")
  56.       (dr-internal (resource-key name) database 0))))
  57.  
  58. (defun default-resources (contact resource-class &optional resource-name)
  59.   "Return the plist of default resources for RESOURCE-CLASS on CONTACT.
  60.    If CONTACT is a string, its taken as a host name."
  61.   (if (stringp contact)
  62.       (let ((display (open-contact-display contact)))
  63.     (unwind-protect
  64.         (default-resources (display-root display) resource-class resource-name)
  65.       (close-display display)))
  66.       
  67.       (let* ((contact-class (class-name (class-of contact)))
  68.          (class-key     (intern (symbol-name resource-class) 'keyword))
  69.          (name-key      (when resource-name (intern (symbol-name resource-name) 'keyword)))
  70.  
  71.          ;; Find resource(s) that match given RESOURCE-CLASS and RESOURCE-NAME
  72.          (resources     (delete
  73.                   nil
  74.                   (append (class-resources   contact-class t)
  75.                       (class-constraints contact-class t))
  76.                   :key #'(lambda(r)
  77.                        (let ((rclass (getf (rest r) :class))
  78.                          (rname  (first r)))
  79.                      (and
  80.                        (eq (or rclass rname) class-key)
  81.                        (or (null resource-name)
  82.                            (eq rname name-key))))))))
  83.     
  84.     (when resources
  85.       (get-resources
  86.         nil
  87.         resources
  88.         contact
  89.         (append (contact-complete-name contact)  (list (or resource-name resource-class)))
  90.         (append (contact-complete-class contact) (list resource-class)))))))
  91.  
  92. (defun class-resources (class &optional full-p)
  93.   "Return the resource list for CLASS.
  94.   When full-p return the full alist."
  95.   (let ((resources (clue-resources class)))
  96.     (unless resources
  97.       (error "~s isn't a CLUE class." class))
  98.     (if full-p
  99.     resources
  100.       (mapcar #'car resources))))
  101.  
  102. (defun get-resources (arglist resources parent full-name full-class)    
  103.   ;; Useful for making init-plists for contacts
  104.   ;; arglist   Specifies  the  ArgList  to   override   resources
  105.   ;;       obtained from the resource database.
  106.   ;; parent Specifies the  parent contact
  107.   ;; full-name Specifies the name of this contact (may be overrid-
  108.   ;;       den by the arglist).
  109.   ;; full-class Specifies the class of this contact.
  110.   
  111.   (declare (type list arglist)
  112.        (type contact parent)
  113.        (type list full-name full-class)
  114.        (values (list values) full-name full-type))
  115.   
  116.   (do* ((table (get-search-table *database* full-name full-class))
  117.     (resources resources (cdr resources))
  118.     (resource (caar resources) (caar resources))
  119.     (value-type nil)
  120.     (arg nil)
  121.     (result nil))
  122.  
  123.        ((endp resources) result)
  124.     
  125.     (setq value-type (getf (cdar resources) :type))
  126.     (if (setq arg (getf arglist resource))
  127.  
  128.     (when value-type
  129.       (let ((carg (convert parent arg value-type)))
  130.         (if (or carg (null arg))
  131.         (setq arg carg)
  132.         (error "The ~s initialization is ~s which isn't type ~s"
  133.                resource arg value-type))))
  134.     
  135.     (let ((value (get-search-resource table resource (getf (cdar resources) :class resource)))
  136.           (db nil))
  137.       
  138.       (if value
  139.  
  140.           ;; Resource in the database
  141.           (when (and (setq arg value) value-type)
  142.         (let ((carg (convert parent value value-type)))
  143.           (if (or carg (null arg))
  144.               (setq arg carg)
  145.               (error "The resource value for ~s is ~s which isn't type ~s"
  146.                  (reverse (cons resource db)) value value-type))))
  147.           
  148.           ;; Resource NOT in the database
  149.           (let ((initform (getf (cdar resources) :initform)))
  150.         (when initform            ; Resource has an initform
  151.           (setq arg (eval initform))    ;************ EVAL ALERT *********
  152.           (when value-type
  153.             (let ((carg (convert parent arg value-type)))
  154.               (if (or carg (null arg))
  155.               (setq arg carg)
  156.               (error "The ~s initialization has :initform ~s which evaluates to ~s which isn't type ~s"
  157.                  resource initform arg value-type)))))))))
  158.     (when arg
  159.       (setq result (list* resource arg result)))))
  160.  
  161.  
  162.  
  163. (defun resource (contact name)
  164.   "Lookup resource NAME for CONTACT"
  165.   (getf (slot-value (the contact contact) 'initialization) name))
  166.  
  167. (defun get-clue-resource-internal (contact name class)
  168.   (let ((initialization (slot-value (the contact contact) 'initialization)))
  169.     (or (getf initialization name)
  170.     (get-search-resource (second initialization) name (or class name)))))
  171.  
  172. ;; The default method
  173. (defmethod convert (contact value (type t))
  174.   "Convert VALUE to TYPE"
  175.   (cond ((and (consp type) (eq (car type) 'or))    ; OR type
  176.      (dolist (typ (cdr type))        ; Use the first conversion that works
  177.        (if (eq typ 'null)
  178.            (when (null value) (return nil))
  179.          (let ((result (convert contact value typ)))
  180.            (when result
  181.          (return result))))))
  182.  
  183.     ((and (consp type) (eq (car type) 'member))    ; MEMBER type
  184.      (unless (keywordp value)
  185.        (setq value (convert contact value 'keyword)))
  186.      (and (member value (cdr type) :test #'eq) value))
  187.  
  188.     ((typep value type) value)        ; If type works, use it!
  189.  
  190.     ((or (stringp value)            ; Last resort, try read-from-string
  191.          (symbolp value))
  192.      (let ((value (string value))
  193.            (*read-base* 10.)
  194.            (eof '#.(gensym)))
  195.        (multiple-value-bind (result index)
  196.            (read-from-string value nil eof)
  197.          (and (= index (length value))
  198.           (not (eq result eof))
  199.           (typep result type)
  200.           result))))
  201.     (t nil)))
  202.  
  203. (defmethod convert (contact value (type (eql 'keyword)))
  204.   (declare (ignore contact))
  205.   (typecase value
  206.     (keyword value)
  207.     (symbol (intern (symbol-name value) 'keyword))
  208.     (string
  209.      (unless (position #\space (the string value))
  210.        (intern (string-upcase value) 'keyword)))
  211.     (otherwise nil)))
  212.  
  213. (defmethod convert (contact value (type (eql 'pixel)))
  214.   (typecase value
  215.     (stringable                    ; a color name
  216.      (when (symbolp value) (setq value (symbol-name value)))
  217.      (let ((screen (contact-screen contact)))
  218.        (cond ((equalp value "WHITE") (screen-white-pixel screen))
  219.          ((equalp value "BLACK") (screen-black-pixel screen))
  220.          (t (let* ((colormap (screen-default-colormap screen))
  221.                (cache (getf (screen-plist screen) :color-cache))
  222.                (pixel (cdr (assoc value cache :test #'equalp))))
  223.           (or pixel
  224.               (progn
  225.             (when (setf pixel (#+lispm si:ignore-errors ;; Color may not be found
  226.                        #-lispm progn 
  227.                         (alloc-color colormap value)))
  228.               (setf (getf (screen-plist screen) :color-cache)
  229.                 (cons (cons value pixel) cache)))
  230.             pixel)))))))
  231.     (pixel value)
  232.     (otherwise nil)))
  233.  
  234. (defmethod convert (contact value (type (eql 'color)))
  235.   (typecase value
  236.     (stringable                   ; a color name
  237.      (lookup-color (screen-default-colormap (contact-screen contact)) value)
  238.      ;; Don't use window-colormap, because that causes a server round-trip.
  239.      ;; (lookup-color (window-colormap contact) value)
  240.      )
  241.     (color value)
  242.     (otherwise nil)))
  243.  
  244. (defmethod convert (contact value (type (eql 'font)))
  245.   (typecase value
  246.     (stringable                   ; a color name
  247.      (open-font (contact-display contact) value))
  248.     (font value)
  249.     (otherwise nil)))
  250.      
  251. (defmethod convert (contact value (type (eql 'pixmap)))
  252.   (typecase value
  253.     (stringable
  254.      (let ((image (convert contact value 'image)))
  255.        (and image (get-pixmap contact image))))
  256.     ((or (rational 0 1)
  257.      (float 0.0 1.0))
  258.      (let ((gray (svref '#(0%gray 6%gray 12%gray 25%gray 37%gray 50%gray 62%gray 75%gray 88%gray 93%gray 100%gray)
  259.             (round (* value 10)))))
  260.        (and gray (boundp gray) (get-pixmap contact (symbol-value gray)))))
  261.     (image (get-pixmap contact value))
  262.     (pixmap value)
  263.     (otherwise nil)))
  264.  
  265. (defmethod convert (contact value (type (eql 'image)))
  266.   (declare (ignore contact))
  267.   (declare (special cluei::*bitmap-images*))
  268.   (typecase value
  269.     (stringable
  270.      (let ((symbol (find value cluei::*bitmap-images* :test #'xlib::stringable-equal)))
  271.        (and symbol
  272.         (boundp symbol)
  273.         (typep (symbol-value symbol) 'image)
  274.         (symbol-value symbol))))
  275.     (image value)
  276.     (otherwise nil)))
  277.  
  278. (defmethod convert (contact value (type (eql 'cursor)))
  279.   (declare (special *cursor-names*))
  280.   (typecase value
  281.     (card8 (get-cursor contact value))
  282.     (stringable
  283.      (let ((entry (assoc (string value) *cursor-names* :test #'string-equal)))
  284.        (cond (entry
  285.           (get-cursor contact (second entry)))
  286.          ((and (stringp value)
  287.            (setq entry (parse-integer value :junk-allowed t)))
  288.           (get-cursor contact entry)))))
  289.     (cursor value)
  290.     (otherwise nil)))
  291.  
  292. (defmethod convert (contact value (type (eql 'boolean)))
  293.   (declare (ignore contact))
  294.   (typecase value
  295.     ((member t nil) value)
  296.     (stringable
  297.      (member value '(:yes :on :true t) :test #'xlib::stringable-equal))
  298.     (otherwise nil)))
  299.  
  300. (defmethod convert (contact value (type (eql 'stringable)))
  301.   (declare (ignore contact))
  302.   (typecase value
  303.     (stringable value)
  304.     (otherwise
  305.      (princ-to-string value))))
  306.  
  307. (defmethod convert (contact value (type (eql 'string)))
  308.   (declare (ignore contact))
  309.   (typecase value
  310.     (string value)
  311.     (symbol (symbol-name value))
  312.     (otherwise
  313.      (princ-to-string value))))
  314.  
  315. (defmacro define-resources (&body name-value-pairs)
  316.   "Sugar coating for xlib:add-resource"
  317.   `(progn ,@(do* ((name-values name-value-pairs (cddr name-values))
  318.           (result nil))
  319.          ((endp name-values) (nreverse result))
  320.           (push `(add-resource *database* ',(first name-values) ,(second name-values)) result))))
  321.  
  322. (defmacro undefine-resources (&body name-value-pairs)
  323.   "Sugar coating for xlib:delete-resource"
  324.   `(progn ,@(do* ((name-values name-value-pairs (cddr name-values))
  325.           (result nil))
  326.          ((endp name-values) (nreverse result))
  327.           (push `(delete-resource *database* ',(first name-values)) result))))
  328.  
  329.  
  330. ;;;-----------------------------------------------------------------------------
  331.  
  332. #| ;; Test code
  333. (setq *database* (make-resource-database))
  334. (define-resources
  335.   clue:(xmail toc button border) 3
  336.   clue:(button font) 'helv10
  337.   clue:(xmail background) 'red
  338.   clue:(button background) 'blue
  339.   clue:(button color) 'green
  340.   clue:(xmail buttonbox color) 'gray
  341.   clue:(xmail buttonbox font) 'fg-18
  342.   clue:(xmail buttonbox foreground) 'red
  343.   clue:(xmail buttonbox background) 'blue
  344.   clue:(xmail buttonbox button color) 'gray
  345.   clue:(application color) 'gray
  346.   clue:(xmail toc button active-foreground) 'black1
  347.   clue:(xmail toc buttonbox button  active-foreground) 'black2
  348.   clue:(xmail toc button    include active-foreground) 'bblack
  349.   clue:(* contact active-foreground) 'ablack
  350.   )
  351.  
  352. (get-resource *database* :active-foreground 'color
  353.           'clue:(xmail       toc         button    include)
  354.           'clue:(application panelwindow buttonbox button))
  355.  
  356. (get-resource *database* :active-foreground 'color
  357.           'clue:(include button toc xmail)
  358.           'clue:(button buttonbox panelwindow application) t)
  359.  
  360. (SETQ vlist (MAKE-ARRAY 20 :fill-pointer 0 :adjustable t))
  361. (get-search-table
  362.   *database*
  363.   'clue:(xmail       toc)
  364.   'clue:(application buttonbox)
  365.   vlist)
  366.  
  367. (get-search-resource vlist :foreground 'color)
  368. (get-search-resource vlist :background 'color)
  369.  
  370. (DEFMACRO define-c-resources (STRING)
  371.   `(WITH-INPUT-FROM-STRING (STREAM ,string)
  372.      (read-resources *database* stream)))
  373.  
  374. (define-c-resources
  375.   "xmail*toc*button*border: 3
  376.   button*font: helv10
  377.   xmail*background: red
  378.   button*background: blue
  379.   button*color: green
  380.   (xmail*buttonbox*color: gray
  381.   xmail*buttonbox*button*color: gray
  382.   application*color: gray
  383.   xmail*toc*button*active-foreground: black
  384.   xmail*toc*buttonbox*button*active-foreground: black
  385.   xmail*toc*button*include*active-foreground: bblack")
  386.  
  387. |#
  388.